home *** CD-ROM | disk | FTP | other *** search
/ IRIS Performer 2.2 Friends Demo / SGI IRIS Performer 2.2 Friends Demo.iso / friends / openworlds / tix / Primitiv.tcl < prev    next >
Text File  |  1997-11-22  |  9KB  |  392 lines
  1. # This is the primitive widget. It is just a frame with proper inheritance
  2. # wrapping. All new Tix widgets will be derived from this widget
  3.  
  4. # No superclass, so the -superclass switch is not used
  5. #
  6. #
  7. tixWidgetClass tixPrimitive {
  8.     -superclass {}
  9.     -classname  TixPrimitive
  10.     -method {
  11.     cget configure subwidget subwidgets
  12.     }
  13.     -flag {
  14.     -background -borderwidth -cursor
  15.     -height -highlightbackground -highlightcolor -highlightthickness
  16.     -options -relief -takefocus -width -bd -bg
  17.     }
  18.     -static {
  19.     -options
  20.     }
  21.     -configspec {
  22.     {-background background Background #d9d9d9} 
  23.     {-borderwidth borderWidth BorderWidth 0} 
  24.     {-cursor cursor Cursor {}} 
  25.     {-height height Height 0}
  26.     {-highlightbackground highlightBackground HighlightBackground #c3c3c3}
  27.     {-highlightcolor highlightColor HighlightColor black}
  28.     {-highlightthickness highlightThickness HighlightThickness 0} 
  29.     {-options options Options {}}
  30.     {-relief relief Relief flat}
  31.     {-takefocus takeFocus TakeFocus 0} 
  32.     {-width width Width 0}
  33.     }
  34.     -alias {
  35.     {-bd -borderwidth}
  36.     {-bg -background}
  37.     }
  38. }
  39.  
  40. #----------------------------------------------------------------------
  41. # ClassInitialization:
  42. #----------------------------------------------------------------------
  43.  
  44. # Override: never
  45. proc tixPrimitive::Constructor {w args} {
  46.  
  47.     upvar #0 $w data
  48.     upvar #0 $data(className) classRec
  49.  
  50.     # Set up some minimal items in the class record.
  51.     #
  52.     set data(w:root)  $w
  53.     set data(rootCmd) $w:root
  54.  
  55.     # We need to create the root widget in order to parse the options
  56.     # database
  57.     tixCallMethod $w CreateRootWidget
  58.  
  59.     # Parse the default options from the options database
  60.     #
  61.     tixPrimitive::ParseDefaultOptions $w
  62.  
  63.     # Parse the options supplied by the user
  64.     #
  65.     tixPrimitive::ParseUserOptions $w $args
  66.  
  67.     # Rename the widget command so that it can be use to access
  68.     # the methods of this class
  69.  
  70.     tixPrimitive::MkWidgetCmd $w
  71.  
  72.     # Inistalize the Widget Record
  73.     #
  74.     tixCallMethod $w InitWidgetRec
  75.  
  76.     # Construct the compound widget
  77.     #
  78.     tixCallMethod $w ConstructWidget
  79.  
  80.     # Do the bindings
  81.     #
  82.     tixCallMethod $w SetBindings
  83.  
  84.     # Call the configuration methods for all "force call" options
  85.     #
  86.     foreach option $classRec(forceCall) {
  87.     tixInt_ChangeOptions $w $option $data($option)
  88.     }
  89. }
  90.  
  91.  
  92. # Create only the root widget. We need the root widget to query the option
  93. # database.
  94. #
  95. # Override: seldom. (unless you want to use a toplevel as root widget)
  96. # Chain   : never.
  97.  
  98. proc tixPrimitive::CreateRootWidget {w args} {
  99.     upvar #0 $w data
  100.     upvar #0 $data(className) classRec
  101.  
  102.     frame $w -class $data(ClassName)
  103. }
  104.  
  105. proc tixPrimitive::ParseDefaultOptions {w} {
  106.     upvar #0 $w data
  107.     upvar #0 $data(className) classRec
  108.  
  109.     # SET UP THE INSTANCE RECORD ACCORDING TO DEFAULT VALUES IN
  110.     # THE OPTIONS DATABASE
  111.     #
  112.     foreach option $classRec(options) {
  113.     set spec [tixInt_GetOptionSpec $data(className) $option]
  114.  
  115.     if {[lindex $spec 0] == "="} {
  116.         continue
  117.     }
  118.  
  119.     set o_name    [lindex $spec 1]
  120.     set o_class   [lindex $spec 2]
  121.     set o_default [lindex $spec 3]
  122.  
  123.     if {![catch "option get $w $o_name $o_class" db_default]} {
  124.         if {$db_default != ""} {
  125.         set data($option) $db_default
  126.         } else {
  127.         set data($option) $o_default
  128.         }
  129.     } else {
  130.         set data($option) $o_default
  131.     }
  132.     }
  133. }
  134.  
  135. proc tixPrimitive::ParseUserOptions {w arglist} {
  136.     upvar #0 $w data
  137.     upvar #0 $data(className) classRec
  138.  
  139.     # SET UP THE INSTANCE RECORD ACCORDING TO COMMAND ARGUMENTS FROM
  140.     # THE USER OF THE TIX LIBRARY (i.e. Application programmer:)
  141.     #
  142.     tixForEach {option arg} $arglist {
  143.     if {[lsearch $classRec(options) $option] != "-1"} {
  144.         set spec [tixInt_GetOptionSpec $data(className) $option]
  145.  
  146.         if {[lindex $spec 0] != "="} {
  147.         set data($option) $arg
  148.         } else {
  149.         set realOption [lindex $spec 1]
  150.         set data($realOption) $arg
  151.         }
  152.     } else {
  153.         error "unknown option $option. Should be: [tixInt_ListOptions $w]"
  154.     }
  155.     }
  156. }
  157.  
  158. #----------------------------------------------------------------------
  159. # Initialize the widget record
  160. # 
  161. #
  162. # Override: always
  163. # Chain   : always, before
  164. proc tixPrimitive::InitWidgetRec {w} {
  165.     # default: do nothing
  166. }
  167.  
  168. #----------------------------------------------------------------------
  169. # SetBindings
  170. # 
  171. #
  172. # Override: sometimes
  173. # Chain   : sometimes, before
  174. #
  175. bind Foo <Destroy> {
  176.     [tixGetMethod %W [set %W(className)] Destructor] %W
  177. }
  178.  
  179. proc tixPrimitive::SetBindings {w} {
  180.     upvar #0 $w data
  181.  
  182.     if {[winfo toplevel $w] == $w} {
  183.     bindtags $w [concat Foo [bindtags $w]]
  184.     } else {
  185.     bind $data(w:root) <Destroy> \
  186.         "[tixGetMethod $w $data(className) Destructor] $w"
  187.     }
  188. }
  189.  
  190. #----------------------------------------------------------------------
  191. # PrivateMethod: ConstructWidget
  192. # 
  193. # Construct and set up the compound widget
  194. #
  195. # Override: sometimes
  196. # Chain   : sometimes, before
  197. #
  198. proc tixPrimitive::ConstructWidget {w} {
  199.     upvar #0 $w data
  200.  
  201.     $data(rootCmd) config \
  202.     -background  $data(-background) \
  203.     -borderwidth $data(-borderwidth) \
  204.     -cursor      $data(-cursor) \
  205.     -relief      $data(-relief)
  206.  
  207.     if {$data(-width) != 0} {
  208.     $data(rootCmd) config -width $data(-width)
  209.     }
  210.     if {$data(-height) != 0} {
  211.     $data(rootCmd) config -height $data(-height)
  212.     }
  213.  
  214.     set rootname *[string range $w 1 end]
  215.  
  216.     tixForEach {spec value} $data(-options) {
  217.     option add $rootname*$spec $value 100
  218.     }
  219. }
  220.  
  221. #----------------------------------------------------------------------
  222. # PrivateMethod: MkWidgetCmd
  223. # 
  224. # Construct and set up the compound widget
  225. #
  226. # Override: sometimes
  227. # Chain   : sometimes, before
  228. #
  229. proc tixPrimitive::MkWidgetCmd {w} {
  230.     upvar #0 $w data
  231.  
  232.     rename $w $data(rootCmd)
  233.     tixInt_MkInstanceCmd $w
  234. }
  235.  
  236.  
  237. #----------------------------------------------------------------------
  238. # ConfigOptions:
  239. #----------------------------------------------------------------------
  240.  
  241. #----------------------------------------------------------------------
  242. # ConfigMethod: config
  243. #
  244. # Configure one option.
  245. # 
  246. # Override: always
  247. # Chain   : automatic.
  248. #
  249. proc tixPrimitive::config {w option value} {
  250.     upvar #0 $w data
  251.  
  252.     case $option {
  253.     {-background -borderwidth -cursor -height -relief
  254.      -width -bd -bg} {
  255.          $data(rootCmd) config $option $value
  256.      }
  257.     }
  258. }
  259.  
  260. #----------------------------------------------------------------------
  261. # PublicMethods:
  262. #----------------------------------------------------------------------
  263.  
  264. #----------------------------------------------------------------------
  265. # This method is used to implement the "subwidgets" widget command.
  266. # Will be re-written in C. It can't be used as a public method because
  267. # of the lame substring comparison routines used in tixClass.c
  268. #
  269. #
  270. proc tixPrimitive::subwidgets {w type args} {
  271.     upvar #0 $w data
  272.  
  273.     case $type {
  274.     -class {
  275.         set name [lindex $args 0]
  276.         set args [lrange $args 1 end]
  277.         # access subwidgets of a particular class
  278.         #
  279.         # note: if $name=="Frame", will *not return the root widget as well
  280.         #
  281.         set sub {}
  282.         foreach des [tixDescendants $w] {
  283.         if {[winfo class $des] == $name} {
  284.             lappend sub $des
  285.         }
  286.         }
  287.  
  288.         # Note: if the there is no subwidget of this class, does not
  289.         # cause any error.
  290.         #
  291.         if {$args == {}} {
  292.         return $sub
  293.         } else {
  294.         foreach des $sub {
  295.             eval $des $args
  296.         }
  297.         return ""
  298.         }
  299.     }
  300.     -group {
  301.         set name [lindex $args 0]
  302.         set args [lrange $args 1 end]
  303.         # access subwidgets of a particular group
  304.         #
  305.         if [info exists data(g:$name)] {
  306.         if {$args == {}} {
  307.             set ret {}
  308.             foreach item $data(g:$name) {
  309.             lappend ret $w.$item
  310.             }
  311.             return $ret
  312.         } else {
  313.             foreach item $data(g:$name) {
  314.             eval $w.$item $args
  315.             }
  316.             return ""
  317.         }
  318.         } else {
  319.         error "no such subwidget group $name"
  320.         }
  321.     }
  322.     -all {
  323.         set sub [tixDescendants $w]
  324.  
  325.         if {$args == {}} {
  326.         return $sub
  327.         } else {
  328.         foreach des $sub {
  329.             eval $des $args
  330.         }
  331.         return ""
  332.         }
  333.     }
  334.     default {
  335.         error "unknown flag $type, should be -all, -class or -group"
  336.     }
  337.     }
  338. }
  339.  
  340. #----------------------------------------------------------------------
  341. # PublicMethod: subwidget
  342. #
  343. # Access a subwidget withe a particular name 
  344. #
  345. # Override: never
  346. # Chain   : never
  347. #
  348. proc tixPrimitive::subwidget {w name args} {
  349.     upvar #0 $w data
  350.  
  351.     if [info exists data(w:$name)] {
  352.     if {$args == {}} {
  353.         return $data(w:$name)
  354.     } else {
  355.         return [eval $data(w:$name) $args]
  356.     }
  357.     } else {
  358.     error "no such subwidget $name"
  359.     }
  360. }
  361.  
  362.  
  363. #----------------------------------------------------------------------
  364. # PrivateMethods:
  365. #----------------------------------------------------------------------
  366.  
  367. # delete the widget record and remove the command
  368. #
  369. proc tixPrimitive::Destructor {w} {
  370.     upvar #0 $w data
  371.  
  372.     if {![info exists data(w:root)]} {
  373.     return
  374.     }
  375.  
  376.     if {[info commands $w] != ""} {
  377.     # remove the command
  378.     #
  379.     rename $w {}
  380.     }
  381.  
  382.     if {[info commands $data(rootCmd)] != ""} {
  383.     # remove the command of the root widget
  384.     #
  385.     rename $data(rootCmd) {}
  386.     }
  387.  
  388.     # delete the widget record
  389.     #
  390.     catch {unset data}
  391. }
  392.